home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / TaskBar Co201085262001.psc / mdPaintSubclass.bas < prev   
Encoding:
BASIC Source File  |  2001-05-27  |  2.3 KB  |  72 lines
  1. Attribute VB_Name = "mdPaintSubclass"
  2. Option Explicit
  3.  
  4. '=========================================================================
  5. ' Constants and variables
  6. '=========================================================================
  7.  
  8. Private Const STR_OLD_PROC      As String = "PAINT_OLDPROC"
  9. Private Const TIMER_ID          As Long = 1
  10. Private Const TIMER_TIMEOUT     As Long = 1000
  11.  
  12. Public Const STR_SHORTTIME      As String = "Short Time"
  13. Public Const STR_LONGDATE       As String = "Long Date"
  14.  
  15. Public UpdateRect           As RECT
  16.  
  17. '=========================================================================
  18. ' Functions
  19. '=========================================================================
  20.  
  21. Public Function PaintSubclass(ByVal hWnd As Long, ByVal lTimeout As Long)
  22.     Dim lOldProc        As Long
  23.     
  24.     On Error Resume Next
  25.     lOldProc = GetWindowLong(hWnd, GWL_WNDPROC)
  26.     SetProp hWnd, STR_OLD_PROC, lOldProc
  27.     SetWindowLong hWnd, GWL_WNDPROC, AddressOf PaintWndProc
  28.     If lTimeout > 0 Then
  29.         SetTimer hWnd, TIMER_ID, lTimeout, 0
  30.     End If
  31. End Function
  32.  
  33. Public Function PaintUnsubclass(ByVal hWnd As Long)
  34.     Dim lOldProc As Long
  35.     
  36.     On Error Resume Next
  37.     lOldProc = GetProp(hWnd, STR_OLD_PROC)
  38.     If lOldProc <> 0 Then
  39.         SetWindowLong hWnd, GWL_WNDPROC, lOldProc
  40.         RemoveProp hWnd, STR_OLD_PROC
  41.     End If
  42.     KillTimer hWnd, TIMER_ID
  43. End Function
  44.  
  45. Private Function PaintWndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  46.     Static sPrevTime    As String
  47.     Dim ps              As PAINTSTRUCT
  48.     Dim lOldProc        As Long
  49.     
  50.     On Error Resume Next
  51.     Select Case uMsg
  52.     Case WM_PAINT
  53.         If GetUpdateRect(hWnd, UpdateRect, 0) <> 0 Then
  54.             BeginPaint hWnd, ps
  55.             SendMessage hWnd, WM_KEYUP, 0, ByVal 0
  56.             EndPaint hWnd, ps
  57.         End If
  58.         Exit Function
  59.     Case WM_CANCELMODE
  60.         SendMessage hWnd, WM_KEYDOWN, 0, ByVal 0
  61.     Case WM_TIMER
  62.         '--- repaint clock if necessary
  63.         If sPrevTime <> Format(Now, STR_SHORTTIME) Then
  64.             sPrevTime = Format(Now, STR_SHORTTIME)
  65.             RefreshDC hWnd
  66.         End If
  67.     End Select
  68.     lOldProc = GetProp(hWnd, STR_OLD_PROC)
  69.     PaintWndProc = CallWindowProc(lOldProc, hWnd, uMsg, wParam, lParam)
  70. End Function
  71.  
  72.